home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / elk-2_0.lha / elk-2.0 / src / special.c < prev    next >
C/C++ Source or Header  |  1992-10-02  |  11KB  |  480 lines
  1. /* Special forms
  2.  */
  3.  
  4. #include "scheme.h"
  5.  
  6. static Object Sym_Else;
  7.  
  8. Init_Special () {
  9.     Define_Symbol (&Sym_Else, "else");
  10. }
  11.  
  12. Object P_Quote (argl) Object argl; {
  13.     return Car (argl);
  14. }
  15.  
  16. Object Quasiquote (x, level) Object x; {
  17.     Object form, list, tail, cell, qcar, qcdr, ret;
  18.     TC_Prolog;
  19.  
  20.     if (TYPE(x) != T_Pair)
  21.     return x;
  22.     if (EQ(Car (x), Sym_Unquote)) {
  23.     x = Cdr (x);
  24.     if (TYPE(x) != T_Pair)
  25.         Primitive_Error ("bad unquote form: ~s", x);
  26.     if (level) {
  27.         ret = Cons (Car (x), Null);
  28.         ret = Quasiquote(ret, level-1);
  29.         ret = Cons (Sym_Unquote, ret);
  30.     } else {
  31.         TC_Disable;
  32.         ret = Eval (Car (x));
  33.         TC_Enable;
  34.     }
  35.     return ret;
  36.     } else if (TYPE(Car (x)) == T_Pair
  37.         && EQ(Car (Car (x)), Sym_Unquote_Splicing)) {
  38.     GC_Node6;
  39.  
  40.     qcdr = Cdr (x);
  41.     form = list = tail = cell = Null;
  42.     x = Car (x);
  43.     if (TYPE(Cdr (x)) != T_Pair)
  44.         Primitive_Error ("bad unquote-splicing form: ~s", x);
  45.     if (level) {
  46.         GC_Link2 (list, qcdr);
  47.         list = Quasiquote(Cdr (x), level-1);
  48.         list = Cons (Sym_Unquote_Splicing, list);
  49.         qcdr = Quasiquote(qcdr, level);
  50.         list = Cons (list, qcdr);
  51.         GC_Unlink;
  52.         return list;
  53.     }
  54.     GC_Link6 (x, qcdr, form, list, tail, cell);
  55.     TC_Disable;
  56.     form = Eval (Car (Cdr (x)));
  57.     TC_Enable;
  58.     for ( ; TYPE(form) == T_Pair; tail = cell, form = Cdr (form)) {
  59.         cell = Cons (Car (form), Null);
  60.         if (Nullp (list))
  61.         list = cell;
  62.         else
  63.         (void)P_Setcdr (tail, cell);
  64.     }
  65.     qcdr = Quasiquote (qcdr, level);
  66.     GC_Unlink;
  67.     if (Nullp (list))
  68.         return qcdr;
  69.     (void)P_Setcdr (tail, qcdr);
  70.     return list;
  71.     } else {
  72.     GC_Node3;
  73.  
  74.     qcar = qcdr = Null;
  75.     GC_Link3 (x, qcar, qcdr);
  76.     if (EQ(Car (x), Sym_Quasiquote))   /* hack! */
  77.         ++level;
  78.     qcar = Quasiquote (Car (x), level);
  79.     qcdr = Quasiquote (Cdr (x), level);
  80.     list = Cons (qcar, qcdr);
  81.     GC_Unlink;
  82.     return list;
  83.     }
  84. }
  85.  
  86. Object P_Quasiquote (argl) Object argl; {
  87.     return Quasiquote (Car (argl), 0);
  88. }
  89.  
  90. Object P_Begin (forms) Object forms; {
  91.     GC_Node;
  92.     TC_Prolog;
  93.  
  94.     if (Nullp (forms))
  95.     return Null;
  96.     GC_Link (forms);
  97.     TC_Disable;
  98.     for ( ; !Nullp (Cdr (forms)); forms = Cdr (forms))
  99.     (void)Eval (Car (forms));
  100.     GC_Unlink;
  101.     TC_Enable;
  102.     return Eval (Car (forms));
  103. }
  104.  
  105. Object P_Begin1 (forms) Object forms; {
  106.     register n;
  107.     Object r, ret;
  108.     GC_Node;
  109.     TC_Prolog;
  110.  
  111.     GC_Link (forms);
  112.     TC_Disable;
  113.     for (n = 1; !Nullp (Cdr (forms)); n = 0, forms = Cdr (forms)) {
  114.     r = Eval (Car (forms));
  115.     if (n)
  116.         ret = r;
  117.     }
  118.     GC_Unlink;
  119.     TC_Enable;
  120.     r = Eval (Car (forms));
  121.     return n ? r : ret;
  122. }
  123.  
  124. Object P_If (argl) Object argl; {
  125.     Object cond, ret;
  126.     GC_Node;
  127.     TC_Prolog;
  128.  
  129.     GC_Link (argl);
  130.     TC_Disable;
  131.     cond = Eval (Car (argl));
  132.     TC_Enable;
  133.     if (Truep(cond))
  134.     ret = Eval (Car (Cdr (argl)));
  135.     else
  136.     ret = Begin (Cdr (Cdr (argl)));
  137.     GC_Unlink;
  138.     return ret;
  139. }
  140.  
  141. Object P_Case (argl) Object argl; {
  142.     Object ret, key, clause, select;
  143.     GC_Node;
  144.     TC_Prolog;
  145.  
  146.     GC_Link (argl);
  147.     ret = False;
  148.     TC_Disable;
  149.     key = Eval (Car (argl));
  150.     for (argl = Cdr (argl); !Nullp (argl); argl = Cdr (argl)) {
  151.     clause = Car (argl);
  152.     Check_List (clause);
  153.     if (Nullp (clause))
  154.         Primitive_Error ("empty clause");
  155.     select = Car (clause);
  156.     if (EQ(select, Sym_Else)) {
  157.         if (!Nullp (Cdr (argl)))
  158.         Primitive_Error ("`else' not in last clause");
  159.         if (Nullp (Cdr (clause)))
  160.         Primitive_Error ("no forms in `else' clause");
  161.     } else if (TYPE(select) == T_Pair) {
  162.         select = P_Memv (key, select);
  163.     } else
  164.         select = P_Eqv (key, select);
  165.     if (Truep (select)) {
  166.         clause = Cdr (clause);
  167.         TC_Enable;
  168.         ret = Nullp (clause) ? True : Begin (clause);
  169.         break;
  170.     }
  171.     }
  172.     TC_Enable;
  173.     GC_Unlink;
  174.     return ret;
  175. }
  176.  
  177. Object P_Cond (argl) Object argl; {
  178.     Object ret, clause, guard;
  179.     int else_clause = 0;
  180.     GC_Node3;
  181.     TC_Prolog;
  182.  
  183.     ret = False;
  184.     clause = guard = Null;
  185.     GC_Link3 (argl, clause, guard);
  186.     TC_Disable;
  187.     for ( ; !Nullp (argl); argl = Cdr (argl)) {
  188.     clause = Car (argl);
  189.     Check_List (clause);
  190.     if (Nullp (clause))
  191.         Primitive_Error ("empty clause");
  192.     guard = Car (clause);
  193.     if (EQ(guard, Sym_Else)) {
  194.         if (!Nullp (Cdr (argl)))
  195.         Primitive_Error ("`else' not in last clause");
  196.         if (Nullp (Cdr (clause)))
  197.         Primitive_Error ("no forms in `else' clause");
  198.         else_clause++;
  199.     } else
  200.         guard = Eval (Car (clause));
  201.     if (Truep (guard)) {
  202.         clause = Cdr (clause);
  203.         if (!else_clause && !Nullp (clause) &&
  204.             EQ(Car (clause), Intern ("=>"))) {
  205.         clause = Cdr (clause);
  206.         if (Nullp (clause) || !Nullp (Cdr (clause)))
  207.             Primitive_Error ("syntax error after =>");
  208.         clause = Eval (Car (clause));
  209.         Check_Procedure (clause);
  210.         guard = Cons (guard, Null);
  211.         TC_Enable;
  212.         ret = Funcall (clause, guard, 0);
  213.         } else {
  214.         TC_Enable;
  215.         ret = Nullp (clause) ? guard : Begin (clause);
  216.         }
  217.         break;
  218.     }
  219.     }
  220.     TC_Enable;
  221.     GC_Unlink;
  222.     return ret;
  223. }
  224.  
  225. Object General_Junction (argl, and) Object argl; register and; {
  226.     Object ret;
  227.     GC_Node;
  228.     TC_Prolog;
  229.  
  230.     ret = and ? True : False;
  231.     if (Nullp (argl))
  232.     return ret;
  233.     GC_Link (argl);
  234.     TC_Disable;
  235.     for ( ; !Nullp (Cdr (argl)); argl = Cdr (argl)) {
  236.     ret = Eval (Car (argl));
  237.     if (and != Truep (ret))
  238.         break;
  239.     }
  240.     TC_Enable;
  241.     if (Nullp (Cdr (argl)))
  242.     ret = Eval (Car (argl));
  243.     GC_Unlink;
  244.     return ret;
  245. }
  246.  
  247. Object P_And (argl) Object argl; {
  248.     return General_Junction (argl, 1);
  249. }
  250.  
  251. Object P_Or (argl) Object argl; {
  252.     return General_Junction (argl, 0);
  253. }
  254.  
  255. Object P_Do (argl) Object argl; {
  256.     Object tail, b, val, test, frame, newframe, len, ret;
  257.     register local_vars;
  258.     GC_Node6;
  259.     TC_Prolog;
  260.  
  261.     b = test = frame = newframe = Null;
  262.     GC_Link6 (argl, tail, b, test, frame, newframe);
  263.     TC_Disable;
  264.     for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
  265.     Check_List (tail);
  266.     b = Car (tail);
  267.     if (Nullp (b))
  268.         Primitive_Error ("bad initialization form");
  269.     val = P_Cdr (b);
  270.     Check_List (val);
  271.     b = Car (b);
  272.     Check_Type (b, T_Symbol);
  273.     if (!Nullp (val))
  274.         val = Eval (Car (val));
  275.     if (!EQ(Assq (b, frame), False))
  276.         Primitive_Error ("~s: duplicate variable binding", b);
  277.     frame = Add_Binding (frame, b, val);
  278.     }
  279.     if (local_vars = !Nullp (frame))
  280.     Push_Frame (frame);
  281.     test = Car (Cdr (argl));
  282.     Check_Type (test, T_Pair);
  283.     while (1) {
  284.     b = Eval (Car (test));
  285.     if (Truep (b))
  286.         break;
  287.     (void)Begin (Cdr (Cdr (argl)));
  288.     if (!local_vars)
  289.         continue;
  290.     newframe = Null;
  291.     for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
  292.         b = Car (tail);
  293.         val = Cdr (b);
  294.         len = P_Length (val);
  295.         val = FIXNUM(len) > 1 ? Car (Cdr (val)) : Car (b);
  296.         newframe = Add_Binding (newframe, Car (b), Eval (val));
  297.     }
  298.     Pop_Frame ();
  299.     Push_Frame (newframe);
  300.     }
  301.     Check_List (Cdr (test));
  302.     TC_Enable;
  303.     ret = Begin (Cdr (test));
  304.     if (local_vars)
  305.     Pop_Frame ();
  306.     GC_Unlink;
  307.     return ret;
  308. }
  309.  
  310. Object General_Let (argl, disc) Object argl; {
  311.     Object frame, b, binding, val, tail, ret;
  312.     GC_Node5;
  313.     TC_Prolog;
  314.  
  315.     frame = b = val = Null;
  316.     GC_Link5 (argl, frame, b, val, tail);
  317.     TC_Disable;
  318.     for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
  319.     Check_List (tail);
  320.     b = Car (tail);
  321.     if (Nullp (b))
  322.         Primitive_Error ("bad binding form");
  323.     val = P_Cdr (b);
  324.     Check_List (val);
  325.     if (!Nullp (val) && !Nullp (Cdr (val)))
  326.         Primitive_Error ("bad binding form");
  327.     b = Car (b);
  328.     Check_Type (b, T_Symbol);
  329.     if (!Nullp (val))
  330.         val = Car (val);
  331.     if (disc == 0) {
  332.         if (!Nullp (val))
  333.         val = Eval (val);
  334.     } else if (disc == 1) {
  335.         Push_Frame (frame);
  336.         if (!Nullp (val))
  337.         val = Eval (val);
  338.         Pop_Frame ();
  339.     } else if (disc == 2)
  340.         val = Null;
  341.     binding = Assq (b, frame);
  342.     if (disc != 1 && !EQ(binding, False))
  343.         Primitive_Error ("~s: duplicate variable binding", b);
  344.     if (disc == 1 && !EQ(binding, False))
  345.         Cdr (binding) = val;
  346.     else
  347.         frame = Add_Binding (frame, b, val);
  348.     }
  349.     Push_Frame (frame);
  350.     if (disc == 2) {
  351.     for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
  352.         b = Car (tail);
  353.         val = Cdr (b);
  354.         if (Nullp (val))
  355.         continue;
  356.         val = Car (val);
  357.         b = Lookup_Symbol (Car (b), 1);
  358.         val = Eval (val);
  359.         Cdr (b) = val;
  360.         SYMBOL(Car (b))->value = val;
  361.     }
  362.     }
  363.     TC_Enable;
  364.     ret = Begin (Cdr (argl));
  365.     Pop_Frame ();
  366.     GC_Unlink;
  367.     return ret;
  368. }
  369.  
  370. Object Named_Let (argl) Object argl; {
  371.     Object b, val, tail, vlist, vtail, flist, ftail, cell;
  372.     GC_Node6;
  373.     TC_Prolog;
  374.  
  375.     tail = vlist = vtail = flist = ftail = Null;
  376.     GC_Link6 (argl, tail, vlist, vtail, flist, ftail);
  377.     TC_Disable;
  378.     for (tail = Car (Cdr (argl)); !Nullp (tail); tail = Cdr (tail)) {
  379.     Check_List (tail);
  380.     b = Car (tail);
  381.     if (Nullp (b))
  382.         Primitive_Error ("bad binding form");
  383.     val = P_Cdr (b);
  384.     Check_List (val);
  385.     if (Nullp (val) || !Nullp (Cdr (val)))
  386.         Primitive_Error ("bad binding form");
  387.     Check_Type (Car (b), T_Symbol);
  388.     if (!Nullp (val))
  389.         val = Car (val);
  390.     cell = Cons (val, Null);
  391.     if (Nullp (flist))
  392.         flist = cell;
  393.     else
  394.         (void)P_Setcdr (ftail, cell);
  395.     ftail = cell;
  396.     cell = Cons (Car (Car (tail)), Null);
  397.     if (Nullp (vlist))
  398.         vlist = cell;
  399.     else
  400.         (void)P_Setcdr (vtail, cell);
  401.     vtail = cell;
  402.     }
  403.     Push_Frame (Add_Binding (Null, Car (argl), Null));
  404.     tail = Cons (vlist, Cdr (Cdr (argl)));
  405.     tail = P_Lambda (tail);
  406.     COMPOUND(tail)->name = Car (argl);
  407.     b = Lookup_Symbol (Car (argl), 1);
  408.     Cdr (b) = tail;
  409.     SYMBOL(Car (argl))->value = tail;
  410.     TC_Enable;
  411.     tail = Funcall (tail, flist, 1);
  412.     Pop_Frame ();
  413.     GC_Unlink;
  414.     return tail;
  415. }
  416.  
  417. Object P_Let (argl) Object argl; {
  418.     if (TYPE(Car (argl)) == T_Symbol)
  419.     return Named_Let (argl);
  420.     else 
  421.     return General_Let (argl, 0);
  422. }
  423.  
  424. Object P_Letseq (argl) Object argl; {
  425.     return General_Let (argl, 1);
  426. }
  427.  
  428. Object P_Letrec (argl) Object argl; {
  429.     return General_Let (argl, 2);
  430. }
  431.  
  432. Object Internal_Fluid_Let (bindings, argl) Object bindings, argl; {
  433.     Object b, sym, val, vec, ret;
  434.     WIND w;
  435.     GC_Node5;
  436.  
  437.     if (Nullp (bindings))
  438.     return Begin (Cdr (argl));
  439.     b = sym = val = Null;
  440.     GC_Link5 (bindings, argl, b, sym, val);
  441.     Check_List (bindings);
  442.     b = Car (bindings);
  443.     if (Nullp (b))
  444.     Primitive_Error ("bad binding form");
  445.     sym = Car (b);
  446.     val = P_Cdr (b);
  447.     Check_List (val);
  448.     Check_Type (sym, T_Symbol);
  449.     if (!Nullp (val))
  450.     val = Car (val);
  451.     if (!Nullp (val))
  452.     val = Eval (val);
  453.     b = Lookup_Symbol (sym, 1);
  454.     vec = Make_Vector (3, Null);
  455.     VECTOR(vec)->data[0] = sym;
  456.     VECTOR(vec)->data[1] = The_Environment;
  457.     VECTOR(vec)->data[2] = Cdr (b);
  458.     Add_Wind (&w, vec, vec);
  459.     Cdr (b) = val;
  460.     SYMBOL(sym)->value = val;
  461.     ret = Internal_Fluid_Let (Cdr (bindings), argl);
  462.     Do_Wind (Car (w.inout));
  463.     GC_Unlink;
  464.     return ret;
  465. }
  466.  
  467. Object P_Fluid_Let (argl) Object argl; {
  468.     Object ret;
  469.     WIND *first = First_Wind, *last = Last_Wind;
  470.     TC_Prolog;
  471.  
  472.     TC_Disable;
  473.     ret = Internal_Fluid_Let (Car(argl), argl);
  474.     if (Last_Wind = last)
  475.     last->next = 0;
  476.     First_Wind = first;
  477.     TC_Enable;
  478.     return ret;
  479. }
  480.